unit smCommonTypes;

interface

uses
  SysUtils, Classes, Windows, smExceptions, Gen2;

type
  PGamePoint = ^TGamePoint;
  TGamePoint = record
    X: Integer;
    Y: Integer;
  end;

  PGameRect = ^TGameRect;
  TGameRect = record
    Left: Integer;
    Top: Integer;
    Width: Integer;
    Height: Integer;

    function Right(): Integer; inline;
    function Bottom(): Integer; inline;
    procedure SetRight(const Value: Integer);
    procedure SetBottom(const Value: Integer);
    procedure SetValue(const ALeft, ATop, AWidth, AHeight: Integer);

    class operator Implicit(A: TGameRect): TGamePoint;
  end;

  TGameListElementReleaseProc = procedure (const Element: Pointer) of Object;
  TGameListArray = array of Pointer;
  TGameList = class
  protected
    FElements: TGameListArray;
    FCount: Integer;
    FElementReleaseProc: TGameListElementReleaseProc;
    FObjectElements: Boolean;

    function GetElement(const Index: Integer): Pointer;
    procedure Grow();
    procedure Clean();

  public
    property Raw: TGameListArray read FElements;
    property Elements[const Index: Integer]: Pointer read GetElement; default;
    property Count: Integer read FCount;
    property ElementReleaseProc: TGameListElementReleaseProc
        read FElementReleaseProc write FElementReleaseProc;
    property ObjectElements: Boolean read FObjectElements write FObjectElements;

    function Add(const Element: Pointer): Pointer;
    function IndexOf(const Element: Pointer): Integer;
    function Pop(const Index: Integer): Pointer; overload;
    function Pop(const Element: Pointer): Pointer; overload;
    function Delete(const Index: Integer): Pointer;
    function Remove(const Element: Pointer): Pointer;
    function DeleteRelease(const Index: Integer): Boolean;
    function RemoveRelease(const Element: Pointer): Boolean;
    procedure Clear();

    constructor Create(); virtual;
    destructor Destroy(); override;
  end;

  TGUIMessage = (
    gmNone, gmMouseMove, gmMouseDown, gmMouseUp, gmKeyPress, gmSceneChanged
  );

  TLoadThreadProc = reference to procedure;
  TLoadThread = class(TThread)
  protected
    FReference: TLoadThreadProc;
    procedure Execute(); override;
  public
    constructor Create(const AReference: TLoadThreadProc); reintroduce;
  end;

  function GamePoint(const X, Y: Integer): TGamePoint;

type
  TExFileStream = class helper for TStream
  public
    function ReadBoolean(): Boolean;
    function ReadByte(): Byte;
    function ReadWord(): Word;
    function ReadDWord(): Cardinal;
    function ReadString(): AnsiString;

    function WriteBoolean(const Value: Boolean): Boolean;
    function WriteByte(const Value: Byte): Boolean;
    function WriteWord(const Value: Word): Boolean;
    function WriteDWord(const Value: Cardinal): Boolean;
    function WriteString(const Value: AnsiString): Boolean;
  end;

  TExTextureMgr = class(TG2TextureMgr)
  private
    FTexturePack: TFileStream;
    FTextureList: array of record
      Name: AnsiString;
      Offset: Cardinal;
      Index: Integer;
      RefCount: Integer;
    end;

    procedure DictClear();

  public
    function OpenPack(const AFileName: String): Boolean;
    function NeedTexture(const AName: AnsiString): TG2Texture2D;
    procedure ReleaseTexture(const ATexture: TG2Texture2D);

    function Finalize(): TG2Result; override;
  end;

implementation

{ TGamePoint }

function GamePoint;
begin
  Result.X := X;
  Result.Y := Y;
end;

{ TGameRect }

class operator TGameRect.Implicit(A: TGameRect): TGamePoint;
begin
  Result.X := A.Left;
  Result.Y := A.Top;
end;

function TGameRect.Right: Integer;
begin
  Result := Left + Width;
end;

function TGameRect.Bottom: Integer;
begin
  Result := Top + Height;
end;

procedure TGameRect.SetRight(const Value: Integer);
begin
  Left := Value - Width;
end;

procedure TGameRect.SetBottom(const Value: Integer);
begin
  Top := Value - Height;
end;

procedure TGameRect.SetValue(const ALeft, ATop, AWidth, AHeight: Integer);
begin
  Left := ALeft;
  Top  := ATop;
  Width  := AWidth;
  Height := AHeight;
end;

{ TGameList }

constructor TGameList.Create;
begin
  inherited Create();
  FCount := 0;
  FObjectElements := False;
  FElementReleaseProc := nil;

  Grow();
end;

function TGameList.GetElement(const Index: Integer): Pointer;
begin
  if (Index < 0) or (Index >= Count) then
    raise EGameListRange.Create(Index, Count);
{$R-}
  Result := FElements[Index];
{$R+}
end;

procedure TGameList.Grow;
begin
  if Length(FElements) = Count then
    SetLength(FElements, Count + 10);
end;

procedure TGameList.Clean;
begin
  if (Length(FElements) - 10) > Count then
    SetLength(FElements, Count + 10);
end;

function TGameList.Add(const Element: Pointer): Pointer;
begin
  Grow();

{$R-}
  FElements[Count] := Element;
{$R+}
  Inc(FCount);

  Result := Element;
end;

function TGameList.IndexOf(const Element: Pointer): Integer;
begin
  for Result := 0 to Count - 1 do
    if FElements[Result] = Element then
      Exit;

  raise EGameListNotFound.Create();
end;

function TGameList.Pop(const Index: Integer): Pointer;
begin
  if (Index < 0) or (Index >= Count) then
    raise EGameListRange.Create(Index, Count);

{$R-}
  if Index < Count - 1 then
    Result := Add(Delete(Index))
  else
    Result := FElements[Index];
{$R+}
end;

function TGameList.Pop(const Element: Pointer): Pointer;
begin
  Result := Element;

  if Assigned(Result) then
    Result := Pop(IndexOf(Element));
end;

function TGameList.Delete(const Index: Integer): Pointer;
begin
  if (Index < 0) or (Index >= Count) then
    raise EGameListRange.Create(Index, Count);

{$R-}
  Result := FElements[Index];
  if Index < Count - 1 then
    Move(
      Pointer(FElements[Index + 1]),
      Pointer(FElements[Index]),
      (Count - 1 - Index) * SizeOf(Pointer)
    );
{$R+}

  Dec(FCount);
  Clean();
end;

function TGameList.Remove(const Element: Pointer): Pointer;
begin
  Result := Element;

  if Assigned(Result) then
    Result := Delete(IndexOf(Element));
end;

function TGameList.DeleteRelease(const Index: Integer): Boolean;
begin
  if ObjectElements then
    TObject(Delete(Index)).Free()

  else if Assigned(ElementReleaseProc) then
    ElementReleaseProc(Delete(Index))

  else
    raise EGameListBadReleaseProc.Create('');

  Result := True;
end;

function TGameList.RemoveRelease(const Element: Pointer): Boolean;
begin
  if ObjectElements then
    TObject(Remove(Element)).Free()

  else if Assigned(ElementReleaseProc) then
    ElementReleaseProc(Remove(Element))

  else
    raise EGameListBadReleaseProc.Create('');

  Result := True;
end;

procedure TGameList.Clear;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
{$R-}
    if ObjectElements then
      TObject(FElements[I]).Free()
    else if Assigned(ElementReleaseProc) then
      ElementReleaseProc(FElements[I]);
{$R+}

  SetLength(FElements, 0);
  FCount := 0;
end;

destructor TGameList.Destroy;
begin
  Clear();
  inherited;
end;

{ TLoadThread }

constructor TLoadThread.Create(const AReference: TLoadThreadProc);
begin
  inherited Create(True);
  FReference := AReference;
  FreeOnTerminate := True;
end;

procedure TLoadThread.Execute;
begin
  FReference();
end;

{ TExFileStream }

function TExFileStream.ReadBoolean: Boolean;
begin
  Result := ReadByte() <> 0;
end;

function TExFileStream.ReadByte: Byte;
begin
  Result := 0;
  Read(Result, 1);
end;

function TExFileStream.ReadWord: Word;
begin
  Result := 0;
  Read(Result, 2);
end;

function TExFileStream.ReadDWord: Cardinal;
begin
  Result := 0;
  Read(Result, 4);
end;

function TExFileStream.ReadString: AnsiString;
var
  Len: Word;
begin
  Len := ReadWord();
  if Len > 0 then
  begin
    SetLength(Result, Len);
    Read(Result[1], Len);
  end
  else
    Result := '';
end;

function TExFileStream.WriteBoolean(const Value: Boolean): Boolean;
begin
  Result := Write(Byte(Value), 1) = 1;
end;

function TExFileStream.WriteByte(const Value: Byte): Boolean;
begin
  Result := Write(Value, 1) = 1;
end;

function TExFileStream.WriteWord(const Value: Word): Boolean;
begin
  Result := Write(Value, 2) = 2;
end;

function TExFileStream.WriteDWord(const Value: Cardinal): Boolean;
begin
  Result := Write(Value, 4) = 4;
end;

function TExFileStream.WriteString(const Value: AnsiString): Boolean;
var
  Len: Word;
begin
  Len := Length(Value);
  Result := WriteWord(Len);
  if Result and (Len > 0) then
    Result := Write(Value[1], Len) = Len;
end;

{ TExTextureMgr }

function TExTextureMgr.OpenPack(const AFileName: String): Boolean;
var
  ResCount: Word;
begin
  Result := FileExists(AFileName);
  if Result then
  begin
    DictClear();

    try
      FTexturePack := TFileStream.Create(
          AFileName, fmOpenRead or fmShareDenyWrite
        );
      ResCount := FTexturePack.ReadWord();

      if ResCount > 0 then
      begin
        SetLength(FTextureList, ResCount);
        while ResCount > 0 do
        begin
          with FTextureList[Length(FTextureList) - ResCount] do
          begin
            Name := FTexturePack.ReadString();
            Offset   := FTexturePack.ReadDWord();
            Index    := -1;
            RefCount := 0;
          end;
          Dec(ResCount);
        end;
      end;

    except
      Result := False;
      DictClear();
    end;

  end;
end;

function TExTextureMgr.NeedTexture(const AName: AnsiString): TG2Texture2D;
var
  I: Integer;
  P: Pointer;
  Ps: Cardinal;
begin
  Result := nil;
  P := nil;

  for I := 0 to High(FTextureList) do
    with FTextureList[I] do
      if AName = Name then
      begin
        if RefCount = 0 then
        begin
          FTexturePack.Seek(Offset, soFromBeginning);
          Ps := FTexturePack.ReadDWord();
          try
            P := AllocMem(Ps);
            FTexturePack.Read(P^, Ps);
            Index := Count; // index of new texture
            Result := CreateTexture2DFromBuffer(WideString(AName), P, Ps);
          except
            on E: EOutOfMemory do P := nil;
            on E: Exception do
            begin
              Index := -1;
              P := nil;
            end;
          end;

          if Assigned(P) then
            FreeMem(P, Ps);
        end
        else
          Result := TG2Texture2D(Textures[Index]);

        if Assigned(Result) then
          Inc(RefCount);

        Break;
      end;
end;

procedure TExTextureMgr.ReleaseTexture(const ATexture: TG2Texture2D);
var
  I: Integer;
begin
  if Assigned(ATexture) then
    for I := 0 to High(FTextureList) do
      with FTextureList[I] do
        if Name = AnsiString(ATexture.Name) then
        begin
          Dec(RefCount);
          if RefCount = 0 then
            ATexture.Free();
          Break;
        end;
end;

procedure TExTextureMgr.DictClear;
begin
  if Assigned(FTexturePack) then
  begin
    FTexturePack.Free();
    FTexturePack := nil;
  end;
  SetLength(FTextureList, 0);
end;

function TExTextureMgr.Finalize: TG2Result;
begin
  DictClear();

  Result := inherited Finalize();
end;

end.
